home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / src / X11 / tclMotif-1.4 / send / tclXtSend.c < prev    next >
C/C++ Source or Header  |  1995-06-29  |  35KB  |  1,270 lines
  1. /* 
  2.  * tclXtSend.c --
  3.  *
  4.  *    This file provides procedures that implement the "send"
  5.  *    command, allowing commands to be passed from interpreter
  6.  *    to interpreter.
  7.  * Status -
  8.  *    being developed
  9.  *
  10.  * Copyright 1993 Jan Newmarch, University of Canberra
  11.  * Permission to use, copy, modify, and distribute this
  12.  * software and its documentation for any purpose and without
  13.  * fee is hereby granted, provided that the above copyright
  14.  * notice appear in all copies.  The author
  15.  * makes no representations about the suitability of this
  16.  * software for any purpose.  It is provided "as is" without
  17.  * express or implied warranty.
  18.  *
  19.  * Copyright 1989-1992 Regents of the University of California
  20.  * Permission to use, copy, modify, and distribute this
  21.  * software and its documentation for any purpose and without
  22.  * fee is hereby granted, provided that the above copyright
  23.  * notice appear in all copies.  The University of California
  24.  * makes no representations about the suitability of this
  25.  * software for any purpose.  It is provided "as is" without
  26.  * express or implied warranty.
  27.  */
  28.  
  29. #ifndef lint
  30. static char rcsid[] = "$Header$";
  31. #endif
  32.  
  33. #include <stdio.h>
  34. #include <stdlib.h>
  35. #include <tcl.h>
  36. #include <X11/Intrinsic.h>
  37. #include <X11/Xatom.h>
  38. #include <X11/Shell.h>
  39. #include <X11/StringDefs.h>
  40.  
  41. #define TM_MAXARGS 100
  42.  
  43. /*
  44.  * This contains info that is common to all widgets
  45.  * created under one display
  46.  */
  47. typedef struct DisplayInfo {
  48.     Display    *display;
  49.     Widget    toplevel;
  50.     Widget    commWidget;
  51.     Atom     registryProperty;
  52.     Atom    commProperty;
  53. } DisplayInfo;
  54.  
  55.  
  56. /* 
  57.  * The following structure is used to keep track of the
  58.  * interpreters registered by this process.
  59.  */
  60.  
  61. typedef struct RegisteredInterp {
  62.     char *name;            /* Interpreter's name (malloc-ed). */
  63.     Tcl_Interp *interp;        /* Interpreter associated with
  64.                  * name. */
  65.     DisplayInfo *dispPtr;    /* Display info associated with name. */
  66.     struct RegisteredInterp *nextPtr;
  67.                 /* Next in list of names associated
  68.                  * with interps in this process.
  69.                  * NULL means end of list. */
  70. } RegisteredInterp;
  71.  
  72. static RegisteredInterp *registry = NULL;
  73.                 /* List of all interpreters
  74.                  * registered by this process. */
  75.  
  76. /*
  77.  * When a result is being awaited from a sent command, one of
  78.  * the following structures is present on a list of all outstanding
  79.  * sent commands.  The information in the structure is used to
  80.  * process the result when it arrives.  You're probably wondering
  81.  * how there could ever be multiple outstanding sent commands.
  82.  * This could happen if interpreters invoke each other recursively.
  83.  * It's unlikely, but possible.
  84.  */
  85.  
  86. typedef struct PendingCommand {
  87.     int serial;            /* Serial number expected in
  88.                  * result. */
  89.     char *target;        /* Name of interpreter command is
  90.                  * being sent to. */
  91.     Tcl_Interp *interp;        /* Interpreter from which the send
  92.                  * was invoked. */
  93.     int code;            /* Tcl return code for command
  94.                  * will be stored here. */
  95.     char *result;        /* String result for command (malloc'ed).
  96.                  * NULL means command still pending. */
  97.     Boolean timedOut;        /* True means timeout proc triggered
  98.                  * false means it hasn't */
  99.     struct PendingCommand *nextPtr;
  100.                 /* Next in list of all outstanding
  101.                  * commands.  NULL means end of
  102.                  * list. */
  103. } PendingCommand;
  104.  
  105. static PendingCommand *pendingCommands = NULL;
  106.                 /* List of all commands currently
  107.                  * being waited for. */
  108.  
  109. /*
  110.  * The information below is used for communication between
  111.  * processes during "send" commands.  Each process keeps a
  112.  * private window, never even mapped, with one property,
  113.  * "Comm".  When a command is sent to an interpreter, the
  114.  * command is appended to the comm property of the communication
  115.  * window associated with the interp's process.  Similarly, when a
  116.  * result is returned from a sent command, it is also appended
  117.  * to the comm property.  In each case, the property information
  118.  * is in the form of an ASCII string.  The exact syntaxes are:
  119.  *
  120.  * Command:
  121.  *    'C' space window space serial space interpName '|' command '\0'
  122.  * The 'C' character indicates that this is a command and not
  123.  * a response.  Window is the hex identifier for the comm
  124.  * window on which to append the response.  Serial is a hex
  125.  * integer containing an identifying number assigned by the
  126.  * sender;  it may be used by the sender to sort out concurrent
  127.  * responses.  InterpName is the ASCII name of the desired
  128.  * interpreter, which must not contain any vertical bar characters
  129.  * The interpreter name is delimited by a vertical bar (this
  130.  * allows the name to include blanks), and is followed by
  131.  * the command to execute.  The command is terminated by a
  132.  * NULL character.
  133.  *
  134.  * Response:
  135.  *    'R' space serial space code space result '\0'
  136.  * The 'R' character indicates that this is a response.  Serial
  137.  * gives the identifier for the command (same value as in the
  138.  * command message).  The code field is a decimal integer giving
  139.  * the Tcl return code from the command, and result is the string
  140.  * result.  The result is terminated by a NULL character.
  141.  *
  142.  * The register of interpreters is kept in a property
  143.  * "InterpRegistry" on the root window of the display.  It is
  144.  * organized as a series of zero or more concatenated strings
  145.  * (in no particular order), each of the form
  146.  *     window space name '\0'
  147.  * where "window" is the hex id of the comm. window to use to talk
  148.  * to an interpreter named "name".
  149.  */
  150.  
  151. /*
  152.  * Maximum size property that can be read at one time by
  153.  * this module:
  154.  */
  155.  
  156. #define MAX_PROP_WORDS 100000
  157.  
  158. /*
  159.  * Forward declarations for procedures defined later in this file:
  160.  */
  161.  
  162. static int    AppendErrorProc _ANSI_ARGS_((Display *display,
  163.             XErrorEvent *errorPtr));
  164. static void    AppendPropCarefully _ANSI_ARGS_((Display *display,
  165.             Window window, Atom property, char *value,
  166.             PendingCommand *pendingPtr));
  167. static void    DeleteProc _ANSI_ARGS_((ClientData clientData));
  168. static Window    LookupName _ANSI_ARGS_((DisplayInfo *dispPtr, char *name,
  169.             int delete));
  170. static void    SendEventProc _ANSI_ARGS_((Widget w, XtPointer clientData,
  171.             XEvent *eventPtr, Boolean *continue_dispatch));
  172. static int    SendInit _ANSI_ARGS_((Tcl_Interp *interp, DisplayInfo *dispPtr));
  173. static void    TimeoutProc _ANSI_ARGS_((XtPointer clientData, 
  174.             XtIntervalId *id));
  175. static int     SendCmd _ANSI_ARGS_ ((ClientData clientData,
  176.             Tcl_Interp *interp, int argc, char **argv));
  177. static int     GetInterpNames _ANSI_ARGS_ ((ClientData clientData,
  178.             Tcl_Interp *interp, int argc, char **argv));
  179.  
  180. /*
  181.  *--------------------------------------------------------------
  182.  *
  183.  * NoOpProc -
  184.  *
  185.  *    Does nothing.
  186.  *
  187.  * Results:
  188.  *    None
  189.  *
  190.  * Side effects:
  191.  *    None
  192.  *
  193.  *--------------------------------------------------------------
  194.  */
  195. static int
  196. NoOpProc(display, event)
  197.     Display *display;
  198.     XErrorEvent *event;
  199. {
  200. #   ifdef DEBUG
  201.     fprintf(stderr, "X error occurred\n");
  202. #   endif
  203. }
  204.  
  205. /*
  206.  *--------------------------------------------------------------
  207.  *
  208.  * TclXtSend_RegisterInterp --
  209.  *
  210.  *    This procedure is called to associate an ASCII name
  211.  *    with an interpreter.  Tm_InitSend must previously
  212.  *    have been called to set up communication channels
  213.  *    and specify a display.
  214.  *
  215.  * Results:
  216.  *    Zero is returned if the name was registered successfully.
  217.  *    Non-zero means the name was already in use.
  218.  *
  219.  * Side effects:
  220.  *    Registration info is saved, thereby allowing the
  221.  *    "send" command to be used later to invoke commands
  222.  *    in the interpreter.  The registration will be removed
  223.  *    automatically when the interpreter is deleted.
  224.  *
  225.  *--------------------------------------------------------------
  226.  */
  227.  
  228. int
  229. TclXtSend_RegisterInterp(interp, name, toplevel)
  230.     Tcl_Interp *interp;        /* Interpreter associated with name. */
  231.     char *name;            /* The name that will be used to
  232.                  * refer to the interpreter in later
  233.                  * "send" commands.  Must be globally
  234.                  * unique. */
  235.     Widget toplevel;        /* toplevel widget for this
  236.                  * interp;  used to identify display
  237.                  * for communication.  */
  238. {
  239. #define TCL_MAX_NAME_LENGTH 1000
  240.     char propInfo[TCL_MAX_NAME_LENGTH + 20];
  241.     register RegisteredInterp *riPtr;
  242.     Window w;
  243.     DisplayInfo *dispPtr;
  244.  
  245. #   ifdef DEBUG
  246.     fprintf(stderr, "registering interpeter %s\n", name);
  247. #   endif
  248.     if (strchr(name, '|') != NULL) {
  249.     interp->result =
  250.         "interpreter name cannot contain '|' character";
  251.     return TCL_ERROR;
  252.     }
  253.  
  254.     dispPtr = (DisplayInfo *) XtMalloc(sizeof(DisplayInfo));
  255.     dispPtr->commWidget = NULL;
  256.     dispPtr->toplevel = toplevel;
  257.     dispPtr->display = XtDisplay(toplevel);
  258.  
  259.     if (dispPtr->commWidget == NULL) {
  260.     int result;
  261.  
  262.     result = SendInit(interp, dispPtr);
  263.     if (result != TCL_OK) {
  264.         return result;
  265.     }
  266.     }
  267.  
  268.     /*
  269.      * Make sure the name is unique, and append info about it to
  270.      * the registry property.  It's important to lock the server
  271.      * here to prevent conflicting changes to the registry property.
  272.      */
  273.  
  274. #   ifndef DONT_GRAB_SERVER
  275.         XGrabServer(dispPtr->display);
  276. #   endif
  277.     w = LookupName(dispPtr, name, 0);
  278.     if (w != (Window) 0) {
  279.     Status status;
  280.     int dummyInt;
  281.     unsigned int dummyUns;
  282.     Window dummyWin;
  283.  
  284.     /*
  285.      * The name is currently registered.  See if the commWidget
  286.      * associated with the name exists.  If not, or if the commWidget
  287.      * is *our* commWidget, then just unregister the old name (this
  288.      * could happen if an application dies without cleaning up the
  289.      * registry).
  290.      */
  291.  
  292.         XSetErrorHandler(NoOpProc);
  293.     status = XGetGeometry(dispPtr->display, w, &dummyWin, &dummyInt,
  294.         &dummyInt, &dummyUns, &dummyUns, &dummyUns, &dummyUns);
  295.         XSetErrorHandler(NULL);
  296.  
  297.     if ((status != 0) && (w != XtWindow(dispPtr->commWidget))) {
  298.         Tcl_AppendResult(interp, "interpreter name \"", name,
  299.             "\" is already in use", (char *) NULL);
  300.         XUngrabServer(dispPtr->display);
  301.         XFlush(dispPtr->display);
  302.         return TCL_ERROR;
  303.     } 
  304.     (void) LookupName(dispPtr, name, 1);
  305.     }
  306.     sprintf(propInfo, "%x %.*s", XtWindow(dispPtr->commWidget),
  307.         TCL_MAX_NAME_LENGTH, name);
  308.     XChangeProperty(dispPtr->display,
  309.         RootWindow(dispPtr->display, 0),
  310.         dispPtr->registryProperty, XA_STRING, 8, PropModeAppend,
  311.         (unsigned char *) propInfo, strlen(propInfo)+1);
  312.     XUngrabServer(dispPtr->display);
  313.     XFlush(dispPtr->display);
  314.  
  315.     /*
  316.      * Add an entry in the local registry of names owned by this
  317.      * process.
  318.      */
  319.  
  320.     riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
  321.     riPtr->name = (char *) ckalloc((unsigned) (strlen(name) + 1));
  322.     strcpy(riPtr->name, name);
  323.     riPtr->interp = interp;
  324.     riPtr->dispPtr = dispPtr;
  325.     riPtr->nextPtr = registry;
  326.     registry = riPtr;
  327.  
  328.     /*
  329.      * Add the "send" command to this interpreter, and arrange for
  330.      * us to be notified when the interpreter is deleted (actually,
  331.      * when the "send" command is deleted).
  332.      */
  333.  
  334.     Tcl_CreateCommand(interp, "send", SendCmd, (ClientData) riPtr,
  335.         DeleteProc);
  336.     Tcl_CreateCommand(interp, "interps", GetInterpNames,
  337.         (ClientData) dispPtr, NULL);
  338.  
  339. #   ifdef DEBUG
  340.     fprintf(stderr, "Registered interpreter successfully\n");
  341. #   endif
  342.  
  343.     return TCL_OK;
  344. }
  345.  
  346. static void
  347. SendRestrictEvents(app, w, pending)
  348.     XtAppContext app;
  349.     Widget w;
  350.     PendingCommand *pending;
  351. {
  352.     XEvent event;
  353.  
  354. #   ifdef DEBUG
  355.     fprintf(stderr, "Restricting events\n");
  356. #   endif
  357.  
  358. #   ifndef DONT_GRAB_SERVER
  359.         XtAddGrab(w, False, False);
  360. #   endif
  361.     while (pending->result == NULL) {
  362.     XtAppNextEvent(app, &event);
  363.     XtDispatchEvent(&event);
  364.     }
  365.     XtRemoveGrab(w);
  366.  
  367. #   ifdef DEBUG
  368.     fprintf(stderr, "Finished restricting events\n");
  369. #   endif
  370. }
  371. /*
  372.  *--------------------------------------------------------------
  373.  *
  374.  * SendCmd --
  375.  *
  376.  *    This procedure is invoked to process the "send" Tcl command.
  377.  *    See the user documentation for details on what it does.
  378.  *
  379.  * Results:
  380.  *    A standard Tcl result.
  381.  *
  382.  * Side effects:
  383.  *    See the user documentation.
  384.  *
  385.  *--------------------------------------------------------------
  386.  */
  387.  
  388. static int
  389. SendCmd(clientData, interp, argc, argv)
  390.     ClientData clientData;        /* Information about sender (only
  391.                      * dispPtr field is used). */
  392.     Tcl_Interp *interp;            /* Current interpreter. */
  393.     int argc;                /* Number of arguments. */
  394.     char **argv;            /* Argument strings. */
  395. {
  396.     RegisteredInterp *senderRiPtr = (RegisteredInterp *) clientData;
  397.     Window w;
  398. #define STATIC_PROP_SPACE 100
  399.     char *property, staticSpace[STATIC_PROP_SPACE];
  400.     int length;
  401.     static int serial = 0;    /* Running count of sent commands.
  402.                  * Used to give each command a
  403.                  * different serial number. */
  404.     PendingCommand pending;
  405.     XtIntervalId timer;
  406.     XtAppContext app;
  407.     register RegisteredInterp *riPtr;
  408.     char *cmd;
  409.     int result;
  410.     Bool (*prevRestrictProc)();
  411.     char *prevArg;
  412.     DisplayInfo *dispPtr = senderRiPtr->dispPtr;
  413.  
  414. #   ifdef DEBUG
  415.     fprintf(stderr, "Sending command\n");
  416. #   endif
  417.  
  418.     if (dispPtr->commWidget == NULL) {
  419.     result = SendInit(interp, dispPtr);
  420.     if (result != TCL_OK) {
  421.         return result;
  422.     }
  423.     }
  424.  
  425.     if (argc < 3) {
  426.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  427.         " interpName arg ?arg ...?\"", (char *) NULL);
  428.     return TCL_ERROR;
  429.     }
  430.     if (argc == 3) {
  431.     cmd = argv[2];
  432.     } else {
  433.     cmd = Tcl_Concat(argc-2, argv+2);
  434.     }
  435. #   ifdef DEBUG
  436.     fprintf(stderr, "  command is: %s\n", cmd);
  437. #   endif
  438.  
  439.     /*
  440.      * See if the target interpreter is local.  If so, execute
  441.      * the command directly without going through the X server.
  442.      * The only tricky thing is passing the result from the target
  443.      * interpreter to the invoking interpreter.  Watch out:  they
  444.      * could be the same!
  445.      */
  446.  
  447.     for (riPtr = registry; riPtr != NULL; riPtr = riPtr->nextPtr) {
  448.     if (strcmp(riPtr->name, argv[1]) != 0) {
  449.         continue;
  450.     }
  451.     if (interp == riPtr->interp) {
  452.         result = Tcl_GlobalEval(interp, cmd);
  453.     } else {
  454.         result = Tcl_GlobalEval(riPtr->interp, cmd);
  455.         interp->result = riPtr->interp->result;
  456.         interp->freeProc = riPtr->interp->freeProc;
  457.         riPtr->interp->freeProc = 0;
  458.         Tcl_ResetResult(riPtr->interp);
  459.     }
  460.     if (cmd != argv[2]) {
  461.         ckfree(cmd);
  462.     }
  463.     return result;
  464.     }
  465.  
  466.     /*
  467.      * Bind the interpreter name to a communication window.
  468.      */
  469.  
  470.     w = LookupName(dispPtr, argv[1], 0);
  471.     if (w == 0) {
  472.     Tcl_AppendResult(interp, "no registered interpeter named \"",
  473.         argv[1], "\"", (char *) NULL);
  474.     if (cmd != argv[2]) {
  475.         ckfree(cmd);
  476.     }
  477.     return TCL_ERROR;
  478.     }
  479.  
  480.     /*
  481.      * Register the fact that we're waiting for a command to
  482.      * complete (this is needed by SendEventProc and by
  483.      * AppendErrorProc to pass back the command's results).
  484.      */
  485.  
  486.     serial++;
  487.     pending.serial = serial;
  488.     pending.target = argv[1];
  489.     pending.interp = interp;
  490.     pending.result = NULL;
  491.     pending.timedOut = FALSE;
  492.     pending.nextPtr = pendingCommands;
  493.     pendingCommands = &pending;
  494.  
  495.     /*
  496.      * Send the command to target interpreter by appending it to the
  497.      * comm window in the communication window.
  498.      */
  499.  
  500.     length = strlen(argv[1]) + strlen(cmd) + 30;
  501.     if (length <= STATIC_PROP_SPACE) {
  502.     property = staticSpace;
  503.     } else {
  504.     property = (char *) ckalloc((unsigned) length);
  505.     }
  506.     sprintf(property, "C %x %x %s|%s",
  507.         XtWindow(dispPtr->commWidget), serial, argv[1], cmd);
  508.     (void) AppendPropCarefully(dispPtr->display, w, dispPtr->commProperty,
  509.         property, &pending);
  510.     if (length > STATIC_PROP_SPACE) {
  511.     ckfree(property);
  512.     }
  513.     if (cmd != argv[2]) {
  514.     ckfree(cmd);
  515.     }
  516. #   ifdef DEBUG
  517.     fprintf(stderr, "Command sent, awaiting rsponse\n");
  518. #   endif
  519.  
  520.     /*
  521.      * Enter a loop processing X events until the result comes
  522.      * in.  If no response is received within a few seconds,
  523.      * then timeout.  While waiting for a result, look only at
  524.      * send-related events (otherwise it would be possible for
  525.      * additional input events, such as mouse motion, to cause
  526.      * other sends, leading eventually to such a large number
  527.      * of nested Tcl_Eval calls that the Tcl interpreter panics).
  528.      */
  529.  
  530.     app = XtWidgetToApplicationContext(dispPtr->commWidget);
  531.     timer = XtAppAddTimeOut(app, 5000, TimeoutProc, (XtPointer) &pending);
  532.  
  533.     SendRestrictEvents(app, dispPtr->commWidget, &pending);
  534.  
  535.     if ( ! pending.timedOut) {
  536.     XtRemoveTimeOut(timer);
  537.     }
  538.  
  539.     /*
  540.      * Unregister the information about the pending command
  541.      * and return the result.
  542.      */
  543.  
  544.     if (pendingCommands == &pending) {
  545.     pendingCommands = pending.nextPtr;
  546.     } else {
  547.     PendingCommand *pcPtr;
  548.  
  549.     for (pcPtr = pendingCommands; pcPtr != NULL;
  550.         pcPtr = pcPtr->nextPtr) {
  551.         if (pcPtr->nextPtr == &pending) {
  552.         pcPtr->nextPtr = pending.nextPtr;
  553.         break;
  554.         }
  555.     }
  556.     }
  557. #   ifdef DEBUG
  558.     fprintf(stderr, "Send over, result: %s, code: %d\n",
  559.         pending.result, pending.code);
  560. #   endif
  561.  
  562.     Tcl_SetResult(interp, pending.result, TCL_DYNAMIC);
  563.     return pending.code;
  564. }
  565. /*
  566.  *----------------------------------------------------------------------
  567.  *
  568.  * GetInterpNames --
  569.  *
  570.  *    This procedure is invoked to fetch a list of all the
  571.  *    interpreter names currently registered for the display
  572.  *    of a particular window.
  573.  *
  574.  * Results:
  575.  *    A standard Tcl return value.  Interp->result will be set
  576.  *    to hold a list of all the interpreter names defined for
  577.  *    tkwin's display.  If an error occurs, then TCL_ERROR
  578.  *    is returned and interp->result will hold an error message.
  579.  *
  580.  * Side effects:
  581.  *    None.
  582.  *
  583.  *----------------------------------------------------------------------
  584.  */
  585.  
  586. static int
  587. GetInterpNames(clientData, interp, argc, argv)
  588.     ClientData clientData;
  589.     Tcl_Interp *interp;        /* Interpreter for returning a result. */
  590.     int argc;
  591.     char **argv;
  592. {
  593.     DisplayInfo *dispPtr = (DisplayInfo *) clientData;
  594.     char *regProp, *separator, *name;
  595.     register char *p;
  596.     int result, actualFormat;
  597.     unsigned long numItems, bytesAfter;
  598.     Atom actualType;
  599.  
  600.     /*
  601.      * Read the registry property.
  602.      */
  603.  
  604.     regProp = NULL;
  605.     result = XGetWindowProperty(dispPtr->display,
  606.         RootWindow(dispPtr->display, 0),
  607.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  608.         False, XA_STRING, &actualType, &actualFormat,
  609.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  610.  
  611.     if (actualType == None) {
  612.     sprintf(interp->result, "couldn't read intepreter registry property");
  613.     return TCL_ERROR;
  614.     }
  615.  
  616.     /*
  617.      * If the property is improperly formed, then delete it.
  618.      */
  619.  
  620.     if ((result != Success) || (actualFormat != 8)
  621.         || (actualType != XA_STRING)) {
  622.     if (regProp != NULL) {
  623.         XFree(regProp);
  624.     }
  625.     sprintf(interp->result, "intepreter registry property is badly formed");
  626.     return TCL_ERROR;
  627.     }
  628.  
  629.     /*
  630.      * Scan all of the names out of the property.
  631.      */
  632.  
  633.     separator = "";
  634.     for (p = regProp; (p-regProp) < numItems; p++) {
  635.     name = p;
  636.     while ((*p != 0) && (!isspace(*p))) {
  637.         p++;
  638.     }
  639.     if (*p != 0) {
  640.         name = p+1;
  641.         name = Tcl_Merge(1, &name);
  642.         Tcl_AppendResult(interp, separator, name, (char *) NULL);
  643.         while (*p != 0) {
  644.         p++;
  645.         }
  646.         separator = " ";
  647.     }
  648.     }
  649.     XFree(regProp);
  650.     return TCL_OK;
  651. }
  652. /*
  653.  *--------------------------------------------------------------
  654.  *
  655.  * SendInit --
  656.  *
  657.  *    This procedure is called to initialize the
  658.  *    communication channels for sending commands and
  659.  *    receiving results.
  660.  *
  661.  * Results:
  662.  *    The result is a standard Tcl return value, which is
  663.  *    normally TCL_OK.  If an error occurs then an error
  664.  *    message is left in interp->result and TCL_ERROR is
  665.  *    returned.
  666.  *
  667.  * Side effects:
  668.  *    Sets up various data structures and windows.
  669.  *
  670.  *--------------------------------------------------------------
  671.  */
  672.  
  673. static void ClearInterpCmd(w, cldata, calldata)
  674.     Widget w;
  675.     XtPointer cldata;
  676.     XtPointer calldata;
  677. {
  678.     Tcl_DeleteCommand((Tcl_Interp*)cldata,"send");
  679. }
  680.  
  681. static int
  682. SendInit(interp, dispPtr)
  683.     Tcl_Interp *interp;        /* Interpreter to use for error
  684.                  * reporting. */
  685.     register DisplayInfo *dispPtr;/* Display to initialize. */
  686.  
  687. {
  688.     Widget parent;
  689.  
  690.     /*
  691.      * Get atoms used as property names.
  692.      */
  693.  
  694.     dispPtr->commProperty = XInternAtom(dispPtr->display,
  695.         "Comm", False);
  696.     dispPtr->registryProperty = XInternAtom(dispPtr->display,
  697.         "InterpRegistry", False);
  698.  
  699.     /*
  700.      * Create the window used for communication, and set up an
  701.      * event handler for it, unless it already exists.
  702.      */
  703.  
  704.     parent = dispPtr->toplevel;
  705.     if ((dispPtr->commWidget = XtNameToWidget(parent, "_comm")) != NULL)
  706.     return TCL_OK;
  707.  
  708.     dispPtr->commWidget = XtVaCreateWidget("_comm",
  709.                     transientShellWidgetClass,
  710.                     parent,
  711.                     XtNgeometry, "10x10", 
  712.                     XtNoverrideRedirect, TRUE,
  713.                     NULL);
  714.     if (dispPtr->commWidget == NULL) {
  715.     return TCL_ERROR;
  716.     }
  717.     XtRealizeWidget(dispPtr->commWidget);
  718.     XtAddEventHandler(dispPtr->commWidget, PropertyChangeMask,
  719.             FALSE, SendEventProc, dispPtr);
  720.     XtAddCallback(dispPtr->commWidget, XtNdestroyCallback,
  721.           ClearInterpCmd,(XtPointer)interp);
  722.     return TCL_OK;
  723. }
  724. /*
  725.  *--------------------------------------------------------------
  726.  *
  727.  * LookupName --
  728.  *
  729.  *    Given an interpreter name, see if the name exists in
  730.  *    the interpreter registry for a particular display.
  731.  *
  732.  * Results:
  733.  *    If the given name is registered, return the ID of
  734.  *    the window associated with the name.  If the name
  735.  *    isn't registered, then return 0.
  736.  *
  737.  * Side effects:
  738.  *    If the registry property is improperly formed, then
  739.  *    it is deleted.  If "delete" is non-zero, then if the
  740.  *    named interpreter is found it is removed from the
  741.  *    registry property.
  742.  *
  743.  *--------------------------------------------------------------
  744.  */
  745.  
  746. static Window
  747. LookupName(dispPtr, name, delete)
  748.     register DisplayInfo *dispPtr;
  749.             /* Display whose registry to check. */
  750.     char *name;        /* Name of an interpreter. */
  751.     int delete;        /* If non-zero, delete info about name. */
  752. {
  753.     char *regProp, *entry;
  754.     register char *p;
  755.     int result, actualFormat;
  756.     unsigned long numItems, bytesAfter;
  757.     Atom actualType;
  758.     Window returnValue;
  759.  
  760.     /*
  761.      * Read the registry property.
  762.      */
  763.  
  764.     regProp = NULL;
  765.     result = XGetWindowProperty(dispPtr->display,
  766.         RootWindow(dispPtr->display, 0),
  767.         dispPtr->registryProperty, 0, MAX_PROP_WORDS,
  768.         False, XA_STRING, &actualType, &actualFormat,
  769.         &numItems, &bytesAfter, (unsigned char **) ®Prop);
  770.  
  771.     if (actualType == None) {
  772.     return 0;
  773.     }
  774.  
  775.     /*
  776.      * If the property is improperly formed, then delete it.
  777.      */
  778.  
  779.     if ((result != Success) || (actualFormat != 8)
  780.         || (actualType != XA_STRING)) {
  781.     if (regProp != NULL) {
  782.         XFree(regProp);
  783.     }
  784.     XDeleteProperty(dispPtr->display,
  785.         RootWindow(dispPtr->display, 0),
  786.         dispPtr->registryProperty);
  787.     return 0;
  788.     }
  789.  
  790.     /*
  791.      * Scan the property for the desired name.
  792.      */
  793.  
  794.     returnValue = (Window) 0;
  795.     entry = NULL;    /* Not needed, but eliminates compiler warning. */
  796.     for (p = regProp; (p-regProp) < numItems; ) {
  797.     entry = p;
  798.     while ((*p != 0) && (!isspace(*p))) {
  799.         p++;
  800.     }
  801.     if ((*p != 0) && (strcmp(name, p+1) == 0)) {
  802.         sscanf(entry, "%x", &returnValue);
  803.         break;
  804.     }
  805.     while (*p != 0) {
  806.         p++;
  807.     }
  808.     p++;
  809.     }
  810.  
  811.     /*
  812.      * Delete the property, if that is desired (copy down the
  813.      * remainder of the registry property to overlay the deleted
  814.      * info, then rewrite the property).
  815.      */
  816.  
  817.     if ((delete) && (returnValue != 0)) {
  818.     int count;
  819.  
  820.     while (*p != 0) {
  821.         p++;
  822.     }
  823.     p++;
  824.     count = numItems - (p-regProp);
  825.     if (count > 0) {
  826.         memcpy((VOID *) entry, (VOID *) p, count);
  827.     }
  828.     XChangeProperty(dispPtr->display,
  829.         RootWindow(dispPtr->display, 0),
  830.         dispPtr->registryProperty, XA_STRING, 8,
  831.         PropModeReplace, (unsigned char *) regProp,
  832.         (int) (numItems - (p-entry)));
  833.     XSync(dispPtr->display, False);
  834.     }
  835.  
  836.     XFree(regProp);
  837.     return returnValue;
  838. }
  839. /*
  840.  *--------------------------------------------------------------
  841.  *
  842.  * SendEventProc --
  843.  *
  844.  *    This procedure is invoked automatically by the toolkit
  845.  *    event manager when a property changes on the communication
  846.  *    window.  This procedure reads the property and handles
  847.  *    command requests and responses.
  848.  *
  849.  * Results:
  850.  *    None.
  851.  *
  852.  * Side effects:
  853.  *    If there are command requests in the property, they
  854.  *    are executed.  If there are responses in the property,
  855.  *    their information is saved for the (ostensibly waiting)
  856.  *    "send" commands. The property is deleted.
  857.  *
  858.  *--------------------------------------------------------------
  859.  */
  860.  
  861. static void
  862. SendEventProc(w, clientData, eventPtr, continue_dispatch)
  863.     Widget w;
  864.     XtPointer clientData;    /* Display information. */    
  865.     XEvent *eventPtr;        /* Information about event. */
  866.     Boolean *continue_dispatch;
  867. {
  868.     DisplayInfo *dispPtr = (DisplayInfo *) clientData;
  869.     char *propInfo;
  870.     register char *p;
  871.     int result, actualFormat;
  872.     unsigned long numItems, bytesAfter;
  873.     Atom actualType;
  874.  
  875. #   ifdef DEBUG
  876.     fprintf(stderr, "Send arriving\n");
  877. #   endif
  878.     if ((eventPtr->xproperty.atom != dispPtr->commProperty)
  879.         || (eventPtr->xproperty.state != PropertyNewValue)) {
  880.     return;
  881.     }
  882.  
  883.     /*
  884.      * Read the comm property and delete it.
  885.      */
  886.  
  887.     propInfo = NULL;
  888.     XSetErrorHandler(NoOpProc);
  889.     result = XGetWindowProperty(dispPtr->display,
  890.         XtWindow(dispPtr->commWidget),
  891.         dispPtr->commProperty, 0, MAX_PROP_WORDS, True,
  892.         XA_STRING, &actualType, &actualFormat,
  893.         &numItems, &bytesAfter, (unsigned char **) &propInfo);
  894.     XSetErrorHandler(NULL);
  895.  
  896.     /*
  897.      * If the property doesn't exist or is improperly formed
  898.      * then ignore it.
  899.      */
  900.  
  901.     if ((result != Success) || (actualType != XA_STRING)
  902.         || (actualFormat != 8)) {
  903.     if (propInfo != NULL) {
  904.         XFree(propInfo);
  905.     }
  906. #    ifdef DEBUG
  907.         fprintf(stderr, "bad property format?\n");
  908. #    endif
  909.     return;
  910.     }
  911.  
  912.     /*
  913.      * The property is divided into records separated by null
  914.      * characters.  Each record represents one command request
  915.      * or response.  Scan through the property one record at a
  916.      * time.
  917.      */
  918.  
  919. #   ifdef DEBUG
  920.     fprintf(stderr, "Property is: %s\n", propInfo);
  921. #   endif
  922.     for (p = propInfo; (p-propInfo) < numItems; ) {
  923.     if (*p == 'C') {
  924.         Window window;
  925.         int serial, resultSize;
  926.         char *resultString, *interpName, *returnProp, *end;
  927.         register RegisteredInterp *riPtr;
  928.         char errorMsg[100];
  929. #define STATIC_RESULT_SPACE 100
  930.         char staticSpace[STATIC_RESULT_SPACE];
  931.  
  932.         /*
  933.          *-----------------------------------------------------
  934.          * This is an incoming command sent by another window.
  935.          * Parse the fields of the command string.  If the command
  936.          * string isn't properly formed, send back an error message
  937.          * if there's enough well-formed information to generate
  938.          * a proper reply;  otherwise just ignore the message.
  939.          *-----------------------------------------------------
  940.          */
  941.  
  942.         p++;
  943.         window = (Window) strtol(p, &end, 16);
  944.         if (end == p) {
  945.         goto nextRecord;
  946.         }
  947.         p = end;
  948.         if (*p != ' ') {
  949.         goto nextRecord;
  950.         }
  951.         p++;
  952.         serial = strtol(p, &end, 16);
  953.         if (end == p) {
  954.         goto nextRecord;
  955.         }
  956.         p = end;
  957.         if (*p != ' ') {
  958.         goto nextRecord;
  959.         }
  960.         p++;
  961.         interpName = p;
  962.         while ((*p != 0) && (*p != '|')) {
  963.         p++;
  964.         }
  965.         if (*p != '|') {
  966.         result = TCL_ERROR;
  967.         resultString = "bad property format for sent command";
  968.         goto returnResult;
  969.         }
  970.         *p = 0;
  971.         p++;
  972.  
  973.         /*
  974.          * Locate the interpreter for the command, then
  975.          * execute the command.
  976.          */
  977.  
  978.         for (riPtr = registry; ; riPtr = riPtr->nextPtr) {
  979.         if (riPtr == NULL) {
  980.             result = TCL_ERROR;
  981.             sprintf(errorMsg,
  982.                 "receiver never heard of interpreter \"%.40s\"",
  983.                 interpName);
  984.             resultString = errorMsg;
  985.             goto returnResult;
  986.         }
  987.         if (strcmp(riPtr->name, interpName) == 0) {
  988.             break;
  989.         }
  990.         }
  991. #        ifdef DEBUG
  992.         fprintf(stderr, "Executing sent command %s\n", p);
  993. #        endif
  994.         result = Tcl_GlobalEval(riPtr->interp, p);
  995.         resultString = riPtr->interp->result;
  996.  
  997.         /*
  998.          * Return the result to the sender.
  999.          */
  1000.  
  1001.         returnResult:
  1002.         resultSize = strlen(resultString) + 30;
  1003.         if (resultSize <= STATIC_RESULT_SPACE) {
  1004.         returnProp = staticSpace;
  1005.         } else {
  1006.         returnProp = (char *) ckalloc((unsigned) resultSize);
  1007.         }
  1008.         sprintf(returnProp, "R %x %d %s", serial, result,
  1009.             resultString);
  1010. #        ifdef DEBUG
  1011.         fprintf(stderr, "returning result: %s\n", returnProp);
  1012. #        endif
  1013.         (void) AppendPropCarefully(dispPtr->display, window,
  1014.             dispPtr->commProperty, returnProp,
  1015.             (PendingCommand *) NULL);
  1016.         if (returnProp != staticSpace) {
  1017.         ckfree(returnProp);
  1018.         }
  1019.     } else if (*p == 'R') {
  1020.         int serial, code;
  1021.         char *end;
  1022.         register PendingCommand *pcPtr;
  1023.  
  1024.         /*
  1025.          *-----------------------------------------------------
  1026.          * This record in the property is a result being
  1027.          * returned for a command sent from here.  First
  1028.          * parse the fields.
  1029.          *-----------------------------------------------------
  1030.          */
  1031.  
  1032. #        ifdef DEBUG
  1033.         fprintf(stderr, "Result being returned\n");
  1034. #        endif
  1035.         p++;
  1036.         serial = strtol(p, &end, 16);
  1037.         if (end == p) {
  1038.         goto nextRecord;
  1039.         }
  1040.         p = end;
  1041.         if (*p != ' ') {
  1042.         goto nextRecord;
  1043.         }
  1044.         p++;
  1045.         code = strtol(p, &end, 10);
  1046.         if (end == p) {
  1047.         goto nextRecord;
  1048.         }
  1049.         p = end;
  1050.         if (*p != ' ') {
  1051.         goto nextRecord;
  1052.         }
  1053.         p++;
  1054.  
  1055.         /*
  1056.          * Give the result information to anyone who's
  1057.          * waiting for it.
  1058.          */
  1059.  
  1060.         for (pcPtr = pendingCommands; pcPtr != NULL;
  1061.             pcPtr = pcPtr->nextPtr) {
  1062.         if ((serial != pcPtr->serial) || (pcPtr->result != NULL)) {
  1063.             continue;
  1064.         }
  1065.         pcPtr->code = code;
  1066.         pcPtr->result = ckalloc((unsigned) (strlen(p) + 1));
  1067.         strcpy(pcPtr->result, p);
  1068.         break;
  1069.         }
  1070.     }
  1071.  
  1072.     nextRecord:
  1073.     while (*p != 0) {
  1074.         p++;
  1075.     }
  1076.     p++;
  1077.     }
  1078.     XFree(propInfo);
  1079. #   ifdef DEBUG
  1080.     fprintf(stderr, "Send handled\n");
  1081. #   endif
  1082. }
  1083. static PendingCommand *globalPendingPtr; /* hack for poor error handling */
  1084. /*
  1085.  *--------------------------------------------------------------
  1086.  *
  1087.  * AppendPropCarefully --
  1088.  *
  1089.  *    Append a given property to a given window, but set up
  1090.  *    an X error handler so that if the append fails this
  1091.  *    procedure can return an error code rather than having
  1092.  *    Xlib panic.
  1093.  *
  1094.  * Results:
  1095.  *    None.
  1096.  *
  1097.  * Side effects:
  1098.  *    The given property on the given window is appended to.
  1099.  *    If this operation fails and if pendingPtr is non-NULL,
  1100.  *    then the pending operation is marked as complete with
  1101.  *    an error.
  1102.  *
  1103.  *--------------------------------------------------------------
  1104.  */
  1105.  
  1106. static void
  1107. AppendPropCarefully(display, window, property, value, pendingPtr)
  1108.     Display *display;        /* Display on which to operate. */
  1109.     Window window;        /* Window whose property is to
  1110.                  * be modified. */
  1111.     Atom property;        /* Name of property. */
  1112.     char *value;        /* Characters (null-terminated) to
  1113.                  * append to property. */
  1114.     PendingCommand *pendingPtr;    /* Pending command to mark complete
  1115.                  * if an error occurs during the
  1116.                  * property op.  NULL means just
  1117.                  * ignore the error. */
  1118. {
  1119.     /* I don't have a full error mechanism going that forms lists
  1120.      * with client_data like Tk does, so I'll indulge in a grotty
  1121.      * piece of code: set a global to hold the PendingCommand and
  1122.      * XSync to force execution of the error handler before anything
  1123.      * else happens. One day, clean this up
  1124.      */
  1125.     XSetErrorHandler(AppendErrorProc);
  1126.     globalPendingPtr = pendingPtr;
  1127.     XChangeProperty(display, window, property, XA_STRING, 8,
  1128.         PropModeAppend, (unsigned char *) value, strlen(value)+1);
  1129.     XSync(display, False);
  1130.     XSetErrorHandler(NULL);
  1131. }
  1132.  
  1133. /*
  1134.  * The procedure below is invoked if an error occurs during
  1135.  * the XChangeProperty operation above.
  1136.  */
  1137.  
  1138.     /* ARGSUSED */
  1139. static int
  1140. AppendErrorProc(display, errorPtr)
  1141.     Display *display;
  1142.     XErrorEvent *errorPtr;    /* Information about error. */
  1143. {
  1144.     PendingCommand *pendingPtr = globalPendingPtr;
  1145.     register PendingCommand *pcPtr;
  1146.  
  1147.     if (pendingPtr == NULL) {
  1148.     return 0;
  1149.     }
  1150.  
  1151.     /*
  1152.      * Make sure this command is still pending.
  1153.      */
  1154.  
  1155.     for (pcPtr = pendingCommands; pcPtr != NULL;
  1156.         pcPtr = pcPtr->nextPtr) {
  1157.     if ((pcPtr == pendingPtr) && (pcPtr->result == NULL)) {
  1158.         pcPtr->result = ckalloc((unsigned) (strlen(pcPtr->target) + 50));
  1159.         sprintf(pcPtr->result,
  1160.             "send to \"%s\" failed (no communication window)",
  1161.             pcPtr->target);
  1162.         pcPtr->code = TCL_ERROR;
  1163.         break;
  1164.     }
  1165.     }
  1166.     return 0;
  1167. }
  1168. /*
  1169.  *--------------------------------------------------------------
  1170.  *
  1171.  * TimeoutProc --
  1172.  *
  1173.  *    This procedure is invoked when too much time has elapsed
  1174.  *    during the processing of a sent command.
  1175.  *
  1176.  * Results:
  1177.  *    None.
  1178.  *
  1179.  * Side effects:
  1180.  *    Mark the pending command as complete, with an error
  1181.  *    message signalling the timeout.
  1182.  *
  1183.  *--------------------------------------------------------------
  1184.  */
  1185.  
  1186. static void
  1187. TimeoutProc(clientData, timer)
  1188.     XtPointer clientData;    /* Information about command that
  1189.                  * has been sent but not yet
  1190.                  * responded to. */
  1191.     XtIntervalId *timer;
  1192. {
  1193.     PendingCommand *pcPtr = (PendingCommand *) clientData;
  1194.     register PendingCommand *pcPtr2;
  1195.  
  1196. #   ifdef DEBUG
  1197.     fprintf(stderr, "Timer gone off\n");
  1198. #   endif
  1199.  
  1200.     /*
  1201.      * Make sure that the command is still in the pending list
  1202.      * and that it hasn't already completed.  Then register the
  1203.      * error.
  1204.      */
  1205.  
  1206.     for (pcPtr2 = pendingCommands; pcPtr2 != NULL;
  1207.         pcPtr2 = pcPtr2->nextPtr) {
  1208.     static char msg[] = "remote interpreter did not respond";
  1209.     if ((pcPtr2 != pcPtr) || (pcPtr2->result != NULL)) {
  1210.         continue;
  1211.     }
  1212.     pcPtr2->code = TCL_ERROR;
  1213.     pcPtr2->result = ckalloc((unsigned) (sizeof(msg) + 1));
  1214.     strcpy(pcPtr2->result, msg);
  1215.     pcPtr2->timedOut = TRUE;
  1216.     return;
  1217.     }
  1218. }
  1219. /*
  1220.  *--------------------------------------------------------------
  1221.  *
  1222.  * DeleteProc --
  1223.  *
  1224.  *    This procedure is invoked by Tcl when a registered
  1225.  *    interpreter is about to be deleted.  It unregisters
  1226.  *    the interpreter.
  1227.  *
  1228.  * Results:
  1229.  *    None.
  1230.  *
  1231.  * Side effects:
  1232.  *    The interpreter given by riPtr is unregistered.
  1233.  *
  1234.  *--------------------------------------------------------------
  1235.  */
  1236.  
  1237. static void
  1238. DeleteProc(clientData)
  1239.     ClientData clientData;    /* Info about registration, passed
  1240.                  * as ClientData. */
  1241. {
  1242.     RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
  1243.     register RegisteredInterp *riPtr2;
  1244.  
  1245. #   ifndef DONT_GRAB_SERVER
  1246.         XGrabServer(riPtr->dispPtr->display);
  1247. #   endif
  1248.     (void) LookupName(riPtr->dispPtr, riPtr->name, 1);
  1249.     XUngrabServer(riPtr->dispPtr->display);
  1250.     XFlush(riPtr->dispPtr->display);
  1251.     if (registry == riPtr) {
  1252.     registry = riPtr->nextPtr;
  1253.     } else {
  1254.     for (riPtr2 = registry; riPtr2 != NULL;
  1255.         riPtr2 = riPtr2->nextPtr) {
  1256.         if (riPtr2->nextPtr == riPtr) {
  1257.         riPtr2->nextPtr = riPtr->nextPtr;
  1258.         break;
  1259.         }
  1260.     }
  1261.     }
  1262.     Tcl_DeleteCommand(riPtr->interp,"interps");
  1263.     if(NULL!=riPtr->dispPtr->commWidget)
  1264.     XtRemoveCallback(riPtr->dispPtr->commWidget,XtNdestroyCallback,
  1265.              ClearInterpCmd,riPtr->interp);
  1266.     ckfree((char *) riPtr->name);
  1267.     ckfree((char *) riPtr);
  1268. }
  1269.  
  1270.